COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 DEFVST						-*-LISP-*-
C00010 00003		CONSTRAINTS, and INITIAL VALUES
C00015 00004	 How to construct structures
C00019 00005
C00024 00006
C00030 00007	 DEFVST
C00042 ENDMK
C⊗;
;;; DEFVST						-*-LISP-*-

;;; Acronym for "DEFine a Vector-like STructure"
;;; All entries in a Vector-like structure are "pointers" (FIXNUMs, LISTs, etc)
;;; Future plans call for
;;;	DEFBST		-  "DEFine a Bitstring-like STructure", useful where
;;;			     the structure is an interface to some memory
;;;			     block required to be sequential by, say, operating
;;;			     system conventions, or hardware needs.
;;;	DEFSTRUCT 	-  "DEFine a general STRUCTure"
;;; 			    which will be done by composing DEFVST and DEFBST.
;;; Vector-like structures are implemented as VECTORs, which are emulated in
;;;	maclisp by HUNKs, and on the LISPMachine by 1-dimensional
;;;	ART-Q arrays;  the package "NILAID" has the emulators.

;;; Free (global) variables controlling actions:
;;;	CONSTRUCTOR-NAMESTRING-PREFIX 	- constructor name is obtained by 
;;;					    concatenating this string with the
;;;					    structure name.
;;;	SELECTOR-NAMESTRING-STYLE	- ()    ==> selector macro name is same
;;;						    as keyword (variable name).
;;;					- "xxx" ==> selector macro name gotten
;;;						    by concatenating structure 
;;;						    name, "xxx", and keyword.
;;;	DEFMACRO-DISPLACE-CALL		- whether or not macro instances should
;;;					  try to clobber with DISPLACE.  See
;;; 					  comments in DEFMAC package.

;;;  Basic macros: 	DEFVST  for defining a structure
;;;			SETVST  for updating a selected component
;;;			  (and SETF)
;;;  Usage is like:
;;;	(DEFVST SHIP 
;;;		(X-POSITION : FIXNUM) 
;;;		Y-POSITION 
;;;		(MASS = 1000.) 
;;;		COLOR )
;;;	(SETVST (SHIP-X-POSITION QE2) 109.)
;;;  or alternatively, since SETVST is abbreviated by SETF, 
;;;	(SETF (SHIP-X-POSITION QE2) 109.)
;;;  The SETVST macro is used in conjunction with DEFVST.  The example 
;;;  use of DEFVST "defines" a vector-like structure of 4 components;  
;;;  the generic name of this structure is "SHIP", and the components are 
;;;  identified by the ordering of what are called keywords -  X-POSITION, 
;;;  Y-POSITION, MASS, and COLOR.  Each "definition" causes the creation of 
;;;	1) A constructor macro, whose name (normally) is obtained by prefixing
;;;	   the string "CONS-A-" onto the generic name of the structure.
;;;	   In the example, this becomes CONS-A-SHIP.  The constructor
;;;	   permits installing values into the component slots at instantiation
;;;	   time, which are evaluated from either the (default) forms supplied 
;;;	   by the invocation of DEFVST, or from the forms obtained by keyword 
;;;	   parameters in the instantiating form.  E.g. 
;;;		(CONS-A-BANK DOLLARS (PLUS 300. WALLET) MANAGER '|Jones, J.|)
;;;	   would put the numerical value of  300.+WALLET  in the DOLLARS 
;;;	   component of a newly-created bank, and install |Jones, J.| as 
;;;	   its MANAGER.
;;; 	2) N selector macros, one for each keyword (which denotes one
;;;	   component slot), which are obtained (normally) by concatenating
;;;	   the generic name, a "-", and the keyword name.  In the example,
;;;	   we have SHIP-X-POSITION, SHIP-Y-POSITION, SHIP-MASS, and
;;;	   SHIP-COLOR.
;;;		2a: (SHIP-X-POSITION QE2) 
;;;		     to obtain the x-coordinate of QE2
;;;		2b: (SETVST (SHIP-X-POSITION QE2) 109.)
;;;		     to change the x-coordinate to of QE2 to 109.
;;;	3) an information structure, stored as the STRUCT=INFO property
;;;	   of the generic name symbol.  This information has the shape
;;;		(DEFVST STRUCT=INFO 
;;;			INDICATOR+GENERIC-NAME 	
;;;			CONSTRUCTOR-NAME 
;;;			NUMBER-OF-NAMED-COMPONENTS 
;;;			COMPONENT-DEFAULT-INITIALIZATION-LISTS )
;;;
;;;	The indicator+generic name is a pair whose car is &STRUCT, so
;;;	  that there may be some chance of identifying these structures;
;;;	  the cdr is the name handed to DEFVST.
;;;	The zero'th element of the initializations is either (), or a
;;;	  3-list of the key-name, selector-name, and default size for the
;;;	  &REST component - the "block" of unnamed components in the
;;;	  structure.   The remaining elements of the initializations are
;;;	  the "initialization lists" for each named component:
;;;		(<key-name> <corresponding-selector>)
;;;				;() initial value, no restrictions
;;;		(<key-name> <corresponding-selector> <ini-val-form>)
;;;				;no restrictions
;;;		(<key-name> <corresponding-selector> 
;;;			    <ini-val-form> . <list-of-types-for-restrictions>)
;;;
;;; 	Using the ABBREV macro (see LIBDOC;ABBREV >), one can selectively
;;;	use other names, but the canonical constructor and canonical
;;;	selector names will still be created at define time.  E.g.
;;;	    (ABBREV MG BANK-MANAGER SENDOFF CONS-A-SHIP)

;;;	CONSTRAINTS, and INITIAL VALUES

;;;	### Warning - this section may not be fully correct, as of 2/21/79 ###

;;;	   Each of the components may be constrained to be a particular 
;;;	type datum, and may be initialized according to the form supplied
;;;	as default by the call to DEFVST.
;;;
;;;	   The syntax for a non-simple component specification is a list with
;;;	the first element beinng the key name, the item following the first 
;;;	"=" in the list being a form whose value is the default initial value 
;;;	for that component in any creations of instances of that structure, 
;;;	and the element following the first ":" is either a type name or list 
;;;	of type names that restricts any creating instance from supplying an 
;;;	initial value of the wrong type.  If a key has a restriction 
;;;	associated with it, but no default initial-value form, then DEFVST 
;;;	picks some default value consistent with the restriction.
;;;	
;;; 	Consider the example
;;;	    (DEFVST BANK 
;;;	    	(DOLLARS : (FIXNUM FLONUM MUMBLE))
;;;	    	MANAGER 
;;;	    	(LIMIT = 1.0E6 : (FIXNUM FLONUM))
;;;	    	&REST 
;;;	    	 VAULTS 300.)
;;;
;;;	First, the macro invocation of DEFVST would expand into
;;;
;;;  (PROGN 'COMPILE
;;;	(EVAL-WHEN (EVAL COMPILE LOAD)
;;;		   (DEFPROP BANK
;;;			    #((&STRUCT . BANK)
;;;			      CONS-A-BANK 
;;;			      3 
;;;			      #((VAULTS BANK-VAULTS 30.)
;;;				(DOLLARS BANK-DOLLARS 0 FIXNUM FLONUM MUMBLE)
;;;				(MANAGER BANK-MANAGER)
;;;				(LIMIT BANK-LIMIT 1.0E6 FIXNUM FLONUM)))
;;;			    STRUCT=INFO)
;;;		   (DEFPROP CONS-A-BANK BANK CONSTRUCTOR)
;;;		   (DEFPROP BANK-DOLLARS (BANK 1) SELECTOR)
;;;		   (DEFPROP BANK-MANAGER (BANK 2) SELECTOR)
;;;		   (DEFPROP BANK-LIMIT (BANK 3) SELECTOR)
;;;		   (DEFPROP BANK-VAULTS (BANK 4 &REST) SELECTOR))
;;;	(DEFVST-DEFMACRO CONS-A-BANK (BANK-MACRO-ARG)
;;;			 (|defvst-construction/|| 'BANK BANK-MACRO-ARG))
;;;	(DEFVST-DEFMACRO BANK-DOLLARS (BANK-MACRO-ARG)
;;;			 `(VREF ,(cadr bank-macro-arg) 1))
;;;	(DEFVST-DEFMACRO BANK-MANAGER (BANK-MACRO-ARG)
;;;			 `(VREF ,(cadr bank-macro-arg) 2))
;;;	(DEFVST-DEFMACRO BANK-LIMIT (BANK-MACRO-ARG)
;;;			 `(VREF ,(cadr bank-macro-arg) 3))
;;;	(DEFVST-DEFMACRO BANK-VAULTS (BANK-MACRO-ARG)
;;;			 `(VREF ,(cadr bank-macro-arg)
;;;			        (+ 4 ,(caddr bank-macro-arg)))))
;;;	which is then evaluated, producing the four macro definitions, and 
;;;	DEFPROPping several informational properties.  [DEFVST-DEFMACRO is
;;; 	a version of DEFMACRO especially tailored to DEFVST]

;;; How to construct structures

;;;	After that, then, a "simple" creation instance is invoked by, say,
;;;			(CONS-A-BANK)
;;;	then yields a vector something like
;;;		#( (&STRUCT . BANK) 0 () 1.0E6 () . . . () )
;;;	- a bank with three named components, and with 30. unnamed 
;;;	components which are accessed as if VAULTS were a vector name. 
;;;	Note that the first element of the vector is a special 
;;;	"structure" indicator, so that code may certify whether something 
;;;	is indeed a structure.	But a more complex invocation
;;;
;;;	    (CONS-A-BANK DOLLARS (CASEQ VIP 
;;;	    			    (FEDERAL 15.0E9)
;;;	    			    (SAVINGS-&-LOAN 10.0E6)
;;;	    			    (MICKEY-MOUSE 1))
;;; 			  LIMIT (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;; 			  VAULTS 12.)
;;;
;;;	illustrates three points of a creating instance - -
;;;	  (1) keywords paired with initial values are just alternating 
;;;	      pairs in the list, and 
;;;	  (2) the forms for initial values are substituted into a piece of
;;;	      code output by the macro, so that they are evaluated at 
;;;	      instantiation time, and
;;;	  (3) the variable CURRENT-CONSTRUCTION is dynamically bound to the
;;;	      structure being created so that it may be referenced; the 
;;;	      installing of initial values happens last.
;;;	Notice how this macro-expands -- 
;;;
;;;  (LET ((CURRENT-CONSTRUCTION (MAKE-VECTOR (1+ 41))))
;;;       (VSET CURRENT-CONSTRUCTION
;;;  		0
;;; 		(STRUCT=INFO-INDC (GET 'BANK 'STRUCT=INFO)))
;;;       (SETVST (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;; 		  (|defvst-typchk/|| (CASEQ VIP
;;;  					    (FEDERAL 1.5E+10)
;;;  					    (SAVINGS-&-LOAN 10000000.0)
;;;  					    (MICKEY-MOUSE 1))
;;;  				     '(FIXNUM FLONUM MUMBLE)
;;;  				     'BANK-DOLLARS))
;;;       (SETVST (BANK-LIMIT CURRENT-CONSTRUCTION)
;;;  		  (|defvst-typchk/|| (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;;  				     '(FIXNUM FLONUM)
;;;  				     'BANK-LIMIT))
;;;       CURRENT-CONSTRUCTION)
;;; 
;;;	This code might actually not run, since it could stop on a Restriction
;;;	Violation if the variable VIP does not have a value among
;;;		{FEDERAL, SAVINGS-&-LOAN, MICKEY-MOUSE}
;;;	for then it would turn up a () for the DOLLARS component, which
;;;	was specified to be restricted to fixnums.



(defun cmptime-eval macro (x) (and (eval (cadr x)) (eval (caddr x))))

(cmptime-eval (status feature maclisp) 
  `(OR (STATUS FEATURE NOLDMSG)
       (PROG2 (TERPRI)
	      (PRINC ',(implode (nconc (exploden '|;Loading DEFVST |)
				       (do ((x (exploden 
						(cond ((caddr (truename infile)))
						      ('/27)))
					       (cdr x)))
					   ((lessp 47. (car x) 58.)
					    x))
				       (exploden '| |)))))))



(eval-when (eval compile load)
	   (cond ((status feature complr)
		  (SPECIAL DEFMACRO-DISPLACE-CALL 
			   CURRENT-CONSTRUCTION  
			   CONSTRUCTOR-NAMESTRING-PREFIX 
			   SELECTOR-NAMESTRING-STYLE)
		  (*EXPR MACROEXPAND-1 
			 VECTORP 
			 |defvst-typchk/|| 
			 |defvst-construction/|| 
			 |defvst-instantiate/|| 
			 |defvst-getmarker/||) ))
)

(eval-when (eval compile)

(defun (IF-MACLISP macro) (x) 
       (and (status feature MACLISP)
	    `(PROGN 'COMPILE ,@(cdr x))))

(defun (IF-NOT-MACLISP macro) (x) 
       (and (not (status feature MACLISP))
	    `(PROGN 'COMPILE ,@(cdr x))))

(defun (IF-LISPM macro) (x) 
       (and (status feature LISPM)
	    `(PROGN 'COMPILE ,@(cdr x))))

(defun (IF-NOT-LISPM macro) (x) 
       (and (not (status feature LISPM))
	    `(PROGN 'COMPILE ,@(cdr x))))

(defun (IF-NIL macro) (x) 
       (and (status feature NIL)
	    `(PROGN 'COMPILE ,@(cdr x))))

(defun (IF-NOT-NIL macro) (x) 
       (and (not (status feature NIL))
	    `(PROGN 'COMPILE ,@(cdr x))))

 )


(eval-when (eval compile)
    (IF-MACLISP
     (defun macro-fun-get macro (x)  `(GET ,(cadr x) 'MACRO))
    )
    (IF-NOT-MACLISP 
     (defun MACRO-FUN-GET macro (x) 
	(let ((g (gensym)))
	     `((LAMBDA (,g)
		       (AND (SYMBOLP ,g)
			    (FBOUNDP ,g)
			    (SETQ ,g (FSYMEVAL ,g))
			    (NOT (ATOM ,g ))
			    (EQ (CAR ,g) 'MACRO)
			    (CDR ,g)))
	         ,(cadr x))))
     )
 )


(eval-when (eval compile load)
    (IF-MACLISP 
     (and (null (macro-fun-get 'ABBREVIATION))
	  (load (cond ((status feature its) '((DSK LIBLSP) ABBREV))
		      ('t `(,(car (get 'LAP 'AUTOLOAD)) ABBREV))) ))
     (and (null (getl 'setf '(fsubr macro)))
	  (abbreviation-displace setf setvst))
     (and (null (macro-fun-get 'VREF)) 
	  (load (cond ((status feature its) '((DSK LIBLSP) NILAID))
		      ('t `(,(car (get 'LAP 'AUTOLOAD)) NILAID))) )))
    (IF-LISPM 
     (and (null (macro-fun-get 'ABBREVIATION))
	  (load '|DSK:LISPM2;ABBREV QFASL|))
     (and (null (macro-fun-get 'VREF)) 
	  (load '|DSK:LISPM2;NILAID QFASL| )))
)


(eval-when (eval compile)
	   (abbreviation list-length length))

(eval-when (compile) 
    (macros t)
    (if-maclisp (*lexpr STRING-APPEND)  ))



(DECLARE (SETQ DEFMACRO-CHECK-ARGS ()
	       DEFMACRO-FOR-COMPILING 'T))


(AND (NOT (BOUNDP 'DEFMACRO-DISPLACE-CALL)) (SETQ DEFMACRO-DISPLACE-CALL 'T))
(AND (NOT (BOUNDP 'SELECTOR-NAMESTRING-STYLE)) 
     (SETQ SELECTOR-NAMESTRING-STYLE '"-"))
(AND (NOT (BOUNDP 'CONSTRUCTOR-NAMESTRING-PREFIX)) 
     (SETQ CONSTRUCTOR-NAMESTRING-PREFIX '"CONS-A-"))

(IF-MACLISP 
    (EVAL-WHEN (EVAL COMPILE LOAD)
	(AND (NOT (GET '|MACRO-macroexpander/|| 'MACRO))
	     (NOT (GET '|MACRO-macroexpander/|| 'AUTOLOAD))
	     (PUTPROP '|MACRO-macroexpander/|| 
		      (GET 'DEFMACRO 'AUTOLOAD) 
		      'AUTOLOAD))
	(AND (NOT (GET 'MACROEXPAND-1 'SUBR))
	     (NOT (GET 'MACROEXPAND-1 'AUTOLOAD))
	     (PUTPROP 'MACROEXPAND-1 (GET 'DEFMACRO 'AUTOLOAD) 'AUTOLOAD))
)

)


(DEFUN (DEFVST-DEFMACRO MACRO) (X)
   (CONS (COND (DEFMACRO-DISPLACE-CALL '|MACRO-macroexpander/||)
	       ('MACRO))
	 (CDR X)))



;;; The macros below represent a "hand-made" structure for the information
;;;  structure kept for STRUCTs, which might have been from


;;;  (DEFVST STRUCT=INFO INDC CNSN SIZE INIS)


(PROGN 'COMPILE 
       (EVAL-WHEN (COMPILE EVAL LOAD)
		  (DEFPROP CONS-A-STRUCT=INFO STRUCT=INFO CONSTRUCTOR)
		  (DEFPROP STRUCT=INFO-INDC (STRUCT=INFO 1) SELECTOR)
		  (DEFPROP STRUCT=INFO-CNSN (STRUCT=INFO 2) SELECTOR)
		  (DEFPROP STRUCT=INFO-SIZE (STRUCT=INFO 3) SELECTOR)
		  (DEFPROP STRUCT=INFO-INIS (STRUCT=INFO 4) SELECTOR)
		  )
       (DEFVST-DEFMACRO CONS-A-STRUCT=INFO (x) 
	       (|defvst-construction/|| 'STRUCT-INFO x))
       (DEFVST-DEFMACRO STRUCT=INFO-INDC (x) `(VREF ,(cadr x) 1))
       (DEFVST-DEFMACRO STRUCT=INFO-CNSN (x) `(VREF ,(cadr x) 2))
       (DEFVST-DEFMACRO STRUCT=INFO-SIZE (x) `(VREF ,(cadr x) 3))
       (DEFVST-DEFMACRO STRUCT=INFO-INIS (x) `(VREF ,(cadr x) 4))
)

;;; (DEFPROP STRUCT=INFO 
;;;	     #( (&STRUCT . STRUCT=INFO)			;Internal struct marker
;;;		(&STRUCT . STRUCT=INFO)			;Indicator+Generic name
;;;	        CONS-A-STRUCT=INFO			;Constructor-macro name
;;;	        4 					;Number of named keys
;;;	        #( ()					;&REST key/selector/len
;;;		   (INDC STRUCT=INFO-INDC () ) 		;Key-names with info
;;;		   (CNSN STRUCT=INFO-CNSN () )		;  for default initial
;;;		   (SIZE STRUCT=INFO-SIZE 4 ) 		;  settings
;;;		   (INIS STRUCT=INFO-INIS () )
;;;	      )					
;;;	     STRUCT=INFO)


(putprop 'STRUCT=INFO 
	 (vector '(&STRUCT . STRUCT=INFO)
		 '(&STRUCT . STRUCT=INFO)
		 'CONS-A-STRUCT=INFO
		 4 
		 (vector ()
			 '(indc struct=info-indc ())
			 '(cnsn struct=info-cnsn ())
			 '(size struct=info-size 0)
			 '(inis struct=info-inis ()))
		 )
	 'STRUCT=INFO )


;;; For now, SETF is only SETVST.  See comments above where ABBREV is loaded

(DEFUN (SETVST MACRO) (X)
   (LET ((VAL (NTH 2 X)) (ARGL (NTH 1 X)) LL SNAME)
	 ;Would like ((() (SNAME . ARGL) VAL) X)
	(SETQ SNAME (CAR ARGL) ARGL (CDR ARGL))
	(AND (OR (NULL ARGL)
		 (NOT (SYMBOLP SNAME))
		 (AND (SETQ LL (GET SNAME 'SELECTOR))	  	  ;either (NAME i)
		      (OR (COND ((NULL (CDDR LL)) (CDR ARGL))	  ; or (NAME i &REST)
				('T (NULL (CDR ARGL))))
			  (CDDR ARGL)))
		 (DO ((X (CADR X) (MACROEXPAND-1 X))
		      (BX) (BC)  (DEFMACRO-DISPLACE-CALL () ))
		     ((OR (ATOM X) 
			  (AND (EQ X BX) (EQ (CAR X) BC))
			  (EQ (CAR X) 'VREF)) 
		      (NOT (EQ (CAR (SETQ LL X)) 'VREF)))
		     (SETQ BC (CAR (SETQ BX X)))))
	     (ERROR '|Incorrect selector - SETVST| SNAME))
	`(VSET ,@(cdr ll) ,val)))

;;; DEFVST

(DEFUN (DEFVST MACRO) (X)
   (LET (  (SELKEYS (CDDR X)) (SNAME (CADR X))  (NKEYS 0)
	    ;Would like ((() SNAME . SELKEYS) X)   
	   (DEFMACRO-DISPLACE-CALL DEFMACRO-DISPLACE-CALL)
	   (SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE)
	   (CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX)
	   CONSTRUCTOR-NAME  RESTP  RESTKEY  RESTSIZEFORM  TYP  TMP 
	   SELMACDEFS  SELDEFPROPS  SELINIS  MAC-ARG-NM )
	(DECLARE (FIXNUM I NKEYS))
	(COND ((NOT (ATOM SNAME))
	       (DO L (CDR SNAME) (CDDR L) (NULL L)
		   (SET (CAR L) (EVAL (CADR L))))
	       (SETQ SNAME (CAR SNAME))))
	(AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME)) (ATOM SELKEYS))
	     (ERROR '|Bad args - DEFVST| X))
	(SETQ NKEYS (LIST-LENGTH SELKEYS))
	(COND ((SETQ TMP (MEMQ '&REST SELKEYS))
	       (SETQ NKEYS (- NKEYS (LIST-LENGTH TMP))
		     RESTKEY (CADR TMP)
		     RESTSIZEFORM (CADDR TMP))
	       (AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM))
		    (ERROR '|Lossage in &REST variable - DEFVST| SELKEYS))))
	(AND (GET SNAME 'STRUCT=INFO)
	     (FORMAT MSGFILES '|}%Warning! }S is already a STRUCTURE | SNAME))
	(SETQ MAC-ARG-NM 
	      (INTERN (STRING-APPEND (GET-PNAME SNAME) '"-MACRO-ARG")))
	(SETQ CONSTRUCTOR-NAME 
	      (INTERN (STRING-APPEND CONSTRUCTOR-NAMESTRING-PREFIX 
				     (GET-PNAME SNAME))))
	 ; RESTP and SELINIS start out null here
	(DO ( (I 1 (1+ I)) (L SELKEYS (CDR L)) (FLAG) (KEYNM) (SELNM) )
	    ( (OR (NULL L) RESTP) )
	  (COND ((ATOM (SETQ KEYNM (CAR L))) 
		 (COND ((EQ KEYNM '&REST)
			(SETQ KEYNM RESTKEY  RESTP 'T)
			(AND (NOT (EQ RESTKEY (CADR L))) 
			     (ERROR '|&REST lossage DEFVST|))))
		 (SETQ TMP () ))
		('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM)))
			     (NOT (SYMBOLP KEYNM)))
			(ERROR '|Bad key-list - DEFVST| SELKEYS))
		    (COND ((ATOM (CDAR L)) (SETQ TMP () ))
			  ('T (SETQ FLAG () )
			      (AND (SETQ TYP (MEMQ '|:| (CDAR L)))
				   (PROG2 (SETQ FLAG 'T) 'T)
				   (SETQ TYP (COND ((ATOM (CADR TYP))
						    (LIST (CADR TYP)))
						   ((CADR TYP)))))
			      (SETQ TMP (COND ((SETQ TMP (MEMQ '= (CDAR L)))
					       (SETQ FLAG 'T)
					       (CADR TMP))
					      (TYP (CDR (ASSQ (CAR TYP)
							      '((FIXNUM . 0) 
								(FLONUM . 0.0)
								(BIGNUM . 500000000000000000000.)
								(SHORTFLOAT 0.0)
								(LIST . () )
								(SYMBOL . FOO)
								(VECTOR . () )	;change this
								(ARRAY . () )	;crap in the
								(HUNK . () )	;real NIL !
								)))) ))
			      (AND (NOT FLAG)
				   (ERROR '|Invalid initialization or restriction - DEFVST|
					  (CAR L)))
			      (SETQ TMP (CONS TMP TYP)))) ))
	  (SETQ SELNM (COND ((NULL SELECTOR-NAMESTRING-STYLE) KEYNM)
			    ((INTERN (STRING-APPEND (GET-PNAME SNAME) 
						    SELECTOR-NAMESTRING-STYLE 
						    (GET-PNAME KEYNM))))))
	  (PUSH (COND ((NOT RESTP) 
		        ;TMP has "(<initialization-form> <restrictions> ... )
		       (PUSH `(QUOTE (,keynm ,selnm ,@tmp)) SELINIS)
		       `(DEFVST-DEFMACRO ,selnm (,mac-arg-nm) 
			  `(VREF ,(cadr ,mac-arg-nm) ,,i)))
		      ('T (SETQ RESTP `(QUOTE (,keynm ,selnm ,restsizeform)))
			  `(DEFVST-DEFMACRO ,selnm (,mac-arg-nm)
			     `(VREF ,(cadr ,mac-arg-nm) 
				    (+ ,,(1+ nkeys) ,(caddr ,mac-arg-nm))))))
		SELMACDEFS)
	  (PUSH `(DEFPROP ,selnm 
			  (,sname  ,i . ,(and restp '(&REST))) 
			  SELECTOR) 
		SELDEFPROPS))
	`(PROGN 'COMPILE
		(EVAL-WHEN (EVAL COMPILE LOAD)
			    ;This abortive PUTPROP is here because MACLISP
			    ; cant handle reading or fasl'ing HUNKs
			   (PUTPROP 
			     ',sname 
			     (VECTOR (|defvst-getmarker/||)
				     ',(cons '&STRUCT sname)
				     ',constructor-name
				     ,nkeys 
				     (VECTOR . ,(cons restp (nreverse selinis))))
			     'STRUCT=INFO)
			   (DEFPROP ,constructor-name ,sname CONSTRUCTOR)
			   ,@(nreverse seldefprops) )
		(DEFVST-DEFMACRO ,constructor-name (,mac-arg-nm)
		       (|defvst-construction/|| ',sname ,mac-arg-nm))
		,@(nreverse selmacdefs))))


(DEFUN |defvst-construction/|| (SNAME ARGL)
  (PROG (SINFO OVERRIDES INIS ACCESSOR-MAC BL OL NOL RESTP NKEYS TOTSIZE TMP)
	(DECLARE (FIXNUM NKEYS TOTSIZE))
	(AND (SETQ OVERRIDES (CDR ARGL)) (PUSH () OVERRIDES))
	(AND (NOT (VECTORP (SETQ SINFO (GET SNAME 'STRUCT=INFO))))
	     (ERROR '|defvst-construction/|| ARGL))
;;; The following could be (DESETQ ((&STRUCT . STRUCT=INFO)
;;;				     INIS INIS 
;;;				     SIZE NKEYS) 
;;;				   SINFO)
	(SETQ INIS (STRUCT=INFO-INIS SINFO)
	      NKEYS (STRUCT=INFO-SIZE SINFO))
	(SETQ RESTP (VREF INIS 0))
	(SETQ TOTSIZE NKEYS)
	(AND RESTP 
	     (SETQ TOTSIZE 
		   (+ TOTSIZE (COND ((AND OVERRIDES (SETQ TMP (GET (CAR RESTP)
								   OVERRIDES)))
				     (COND ((EQ (TYPEP TMP) 'FIXNUM))
					   ((>= TMP 0))
					   ((ERROR '|Bad &REST arg quantity| 
						ARGL)))
				     TMP)
				    ((CADDR RESTP))))))
	(DO ( (I NKEYS (1- I)) (FLAG () () ) KEYNAME TYPL FORM )
	    ( (<= I 0) )
	  (DESETQ (KEYNAME ACCESSOR-MAC FORM . TYPL) (VREF INIS I))
	  (AND (SETQ TMP (GETL OVERRIDES (LIST KEYNAME)))
	       (SETQ FORM (CADR TMP) FLAG 'T))
	  (AND FORM 
	       (SETQ FORM `(SETVST (,accessor-mac CURRENT-CONSTRUCTION)
				   ,(cond ((null typl) form)
					  (`(|defvst-typchk/|| 
					     ,form
					     ',typl 
					     ',accessor-mac)))))
	       (COND (FLAG  (PUSH (CONS KEYNAME FORM) OL))
		     ('T (PUSH FORM BL)))))
	(AND OL (DO L (CDR OVERRIDES) (CDDR L) (NULL L)
		    (AND (SETQ TMP (ASSQ (CAR L) OL))
			 (PUSH (CDR TMP) NOL))))
	(RETURN `(LET ( (CURRENT-CONSTRUCTION (MAKE-VECTOR ,(1+ totsize))) )
		      (VSET CURRENT-CONSTRUCTION
			    0 
			    (STRUCT=INFO-INDC (get ',sname 'STRUCT=INFO)))
		      ,@(nreverse bl)
		      ,@(nreverse nol) 
		      CURRENT-CONSTRUCTION))))

(DEFUN |defvst-getmarker/|| () 
   (PROG (SINFO)
      A  (COND ((NULL (SETQ SINFO (GET 'STRUCT=INFO 'STRUCT=INFO)))
		(BREAK |Please Load DEFVST|)
		(GO A)))
	 (RETURN (STRUCT=INFO-INDC SINFO))))


(DEFUN |defvst-typchk/|| (VAL TYPL ACCESSOR-MAC)
    (PROG (NTYP SNAME KEY)
     A	 (AND (MEMQ (SETQ NTYP (TYPEP VAL)) TYPL) (RETURN VAL))
	  ;Accessor-macro name has a SELECTOR property of "(<sname> <index>)"
	  ; where <sname> is the structure name, and <index> is the vector
	  ; index corresponding to the key-name
	  ;For now, the first slot of a structure-vector is taken up by the 
	  ; &STRUCT marker, so the access of the initializations list(vector)
	  ; must be made to correspond.
	 (AND (NULL SNAME) 
	      (SETQ SNAME (NTH 0 (SETQ NTYP (GET ACCESSOR-MAC 'SELECTOR))) 
		    KEY (CAR (VREF (STRUCT=INFO-INIS (GET SNAME 'STRUCT=INFO))
				   (COND ((EQ (NTH 2 NTYP) '&REST) 0)
					 ((NTH 1 NTYP)))))))
	 (FORMAT MSGFILES 
		 '|}%;Restriction Violation while creating a }S structure.}%
;The }S component is being set to }S}%; which is supposed to be of type }S|
		 SNAME 
		 KEY 
		 VAL
		 (COND ((CDR TYPL) TYPL)
		       ((CAR TYPL))))
	 (SETQ VAL (ERROR '|DEFVST Restriction Violation| 
			  (LIST SNAME KEY VAL)
			  'WRNG-TYPE-ARG))
	 (GO A)))